home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / RowColumn.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  12.9 KB  |  348 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         RowColumn.lsp
  5. ; RCS:          $Header: RowColumn.lsp,v 1.2 91/10/05 03:57:55 mayer Exp $
  6. ; Description:  Some examples of XmCreateSimpleRadioBox(),
  7. ;        XmCreateSimpleCheckBox(), and XmCreateSimpleOptionMenu().
  8. ;        Note that XmCreateSimpleOptionMenu() invokes window manager
  9. ;        "close" bug. See ./../doc/BUGS for details.
  10. ; Author:       Niels Mayer, HPLabs
  11. ; Created:      Sun Feb 10 20:34:01 1991
  12. ; Modified:     Sat Oct  5 03:54:34 1991 (Niels Mayer) mayer@hplnpm
  13. ; Language:     Lisp
  14. ; Package:      N/A
  15. ; Status:       X11r5 contrib tape release
  16. ;
  17. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  18. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  19. ;
  20. ; Permission to use, copy, modify, distribute, and sell this software and its
  21. ; documentation for any purpose is hereby granted without fee, provided that
  22. ; the above copyright notice appear in all copies and that both that
  23. ; copyright notice and this permission notice appear in supporting
  24. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  25. ; used in advertising or publicity pertaining to distribution of the software
  26. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  27. ; makes no representations about the suitability of this software for any
  28. ; purpose.  It is provided "as is" without express or implied warranty.
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (if (and (eq *MOTIF_VERSION* 1) (eq *MOTIF_REVISION* 0))
  32.     (error "Most features in RowColumn.lsp are present only in Motif 1.1 -- 1.0 doesn't have them yet."))
  33.  
  34. ;;
  35. ;; Add a method on the widget metaclass WIDGET_CLASS. The method allow use of
  36. ;; simpler notation for doing XtGetValues() for a single resource.
  37. ;; (send <widget-class> :get :<resource-name>) ==> returns the resource value.
  38. ;;
  39. (send WIDGET_CLASS :answer :get '(resource-name)
  40.       '(
  41.     (car (send self :GET_VALUES resource-name NIL))
  42.     ))
  43.  
  44. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45. ;; Test XmCreateSimpleRadioBox
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. (let ()
  48.   (setq top_w
  49.     (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "srbshl"
  50.           :XMN_TITLE    "Simple Radio Box Test"
  51.           :XMN_ICON_NAME    "Test"
  52.           ))
  53.   (setq scrl_w
  54.     (send XM_SCROLLED_WINDOW_WIDGET_CLASS :new :managed
  55.           "sc" top_w
  56.           :XMN_SCROLLING_POLICY :AUTOMATIC
  57.           ))
  58.   (setq button-labels
  59.     (do* ((i  100 (1- i))
  60.           (bl '() (cons (format nil "Button ~A" i) bl))
  61.           )
  62.          ((<= i 0)            ;test
  63.           bl            ;return
  64.           )
  65.          ))
  66.   (setq rc_w
  67.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_radio_box
  68.           "rc" scrl_w
  69.           :XMN_BUTTON_COUNT (length button-labels)
  70.           :XMN_BUTTONS button-labels
  71.           ))
  72.   (send rc_w :set_callback :XMN_ENTRY_CALLBACK
  73.     '(CALLBACK_ENTRY_WIDGET
  74.       CALLBACK_ENTRY_SET)
  75.     '(
  76.       (if CALLBACK_ENTRY_SET
  77.           (format T "Radio-Box Select: name==~A label==~A\n"
  78.               (send CALLBACK_ENTRY_WIDGET :name)
  79.               (xm_string_get_l_to_r
  80.                (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  81.         )
  82.       ))
  83.  
  84.   (send top_w :realize)
  85.   )
  86.  
  87. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  88. ;; Test XmCreateSimpleCheckBox()
  89. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90. (let ()
  91. (setq top_w
  92.       (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "scbshl"
  93.         :XMN_TITLE        "Simple Check Box"
  94.         :XMN_ICON_NAME    "SCB"
  95.         ))
  96. (setq scrl_w
  97.       (send XM_SCROLLED_WINDOW_WIDGET_CLASS :new :managed
  98.         "sc" top_w
  99.         :XMN_SCROLLING_POLICY :AUTOMATIC
  100.         ))
  101. (setq button-labels
  102.       (do* ((i  100 (1- i))
  103.         (bl '() (cons (format nil "Button ~A" i) bl))
  104.         )
  105.        ((<= i 0)            ;test
  106.         bl                ;return
  107.         )
  108.        ))
  109. (setq rc_w
  110.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_check_box
  111.         "rc" scrl_w
  112.         :XMN_BUTTON_COUNT    (length button-labels)
  113.         :XMN_BUTTONS    button-labels
  114.         ))
  115. (send rc_w :set_callback :XMN_ENTRY_CALLBACK
  116.       '(CALLBACK_ENTRY_WIDGET
  117.     CALLBACK_ENTRY_SET)
  118.       '(
  119.     (format T "Check-Box ~A: name==~A label==~A\n"
  120.             (if CALLBACK_ENTRY_SET "Select" "Unselect")
  121.             (send CALLBACK_ENTRY_WIDGET :name)
  122.             (xm_string_get_l_to_r
  123.              (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING))
  124.             )
  125.     ))
  126.  
  127. (send top_w :realize)
  128. )
  129.  
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131. ;; Test XmCreateSimpleOptionMenu()
  132. ;;
  133. ;; Unfortunately something about all popup menus in Motif 1.1.1 is screwy...
  134. ;; everything works fine, but if you close the window using mwm's f.kill,
  135. ;; it either won't delete the window, or it will coredump.
  136. ;;
  137. ;; I've seen odd behavior on Motif's standard popup menu example (in C),
  138. ;; so I think this is a motif bug. Fixed in WINTERP version 1.14...
  139. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  140. (if (and (= *WINTERP_VERSION* 1) (>= *WINTERP_REVISION* 14))
  141. (let ()
  142. (setq top_w
  143.       (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "somshl"
  144.         :XMN_TITLE        "Simple Option Menu"
  145.         :XMN_ICON_NAME    "SOM"
  146.         ))
  147. (setq scrl_w
  148.       (send XM_SCROLLED_WINDOW_WIDGET_CLASS :new :managed
  149.         "sc" top_w
  150.         :XMN_SCROLLING_POLICY :AUTOMATIC
  151.         ))
  152. (setq rc_w
  153.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed
  154.         "rc" scrl_w
  155.         :XMN_ORIENTATION :VERTICAL
  156.         :XMN_PACKING :PACK_TIGHT
  157.         :XMN_ENTRY_ALIGNMENT :ALIGNMENT_CENTER
  158.         ))
  159.  
  160. (setq op1_w
  161.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  162.         "rc" rc_w
  163.         :XMN_OPTION_LABEL        "Option 1"
  164.         :XMN_OPTION_MNEMONIC    #\1
  165.         :XMN_BUTTON_COUNT        10
  166.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  167.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  168.         :XMN_BUTTON_SET        1
  169.         ))
  170. (setq op2_w
  171.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  172.         "rc" rc_w
  173.         :XMN_OPTION_LABEL        "Option 2"
  174.         :XMN_OPTION_MNEMONIC    #\2
  175.         :XMN_BUTTON_COUNT        10
  176.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  177.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  178.         :XMN_BUTTON_SET        2
  179.         ))
  180. (setq op3_w
  181.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  182.         "rc" rc_w
  183.         :XMN_OPTION_LABEL        "Option 3"
  184.         :XMN_OPTION_MNEMONIC    #\3
  185.         :XMN_BUTTON_COUNT        10
  186.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  187.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  188.         :XMN_BUTTON_SET        3
  189.         ))
  190. (setq op4_w
  191.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  192.         "rc" rc_w
  193.         :XMN_OPTION_LABEL        "Option 4"
  194.         :XMN_OPTION_MNEMONIC    #\4
  195.         :XMN_BUTTON_COUNT        10
  196.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  197.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  198.         :XMN_BUTTON_SET        4
  199.         ))
  200. (setq op5_w
  201.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  202.         "rc" rc_w
  203.         :XMN_OPTION_LABEL        "Option 5"
  204.         :XMN_OPTION_MNEMONIC    #\5
  205.         :XMN_BUTTON_COUNT        10
  206.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  207.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  208.         :XMN_BUTTON_SET        5
  209.         ))
  210. (setq op6_w
  211.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  212.         "rc" rc_w
  213.         :XMN_OPTION_LABEL        "Option 6"
  214.         :XMN_OPTION_MNEMONIC    #\6
  215.         :XMN_BUTTON_COUNT        10
  216.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  217.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  218.         :XMN_BUTTON_SET        6
  219.         ))
  220. (setq op7_w
  221.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  222.         "rc" rc_w
  223.         :XMN_OPTION_LABEL        "Option 7"
  224.         :XMN_OPTION_MNEMONIC    #\7
  225.         :XMN_BUTTON_COUNT        10
  226.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  227.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  228.         :XMN_BUTTON_SET        7
  229.         ))
  230. (setq op8_w
  231.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  232.         "rc" rc_w
  233.         :XMN_OPTION_LABEL        "Option 8"
  234.         :XMN_OPTION_MNEMONIC    #\8
  235.         :XMN_BUTTON_COUNT        10
  236.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  237.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  238.         :XMN_BUTTON_SET        8
  239.         ))
  240. (setq op9_w
  241.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_option_menu
  242.         "rc" rc_w
  243.         :XMN_OPTION_LABEL        "Option 9"
  244.         :XMN_OPTION_MNEMONIC    #\9
  245.         :XMN_BUTTON_COUNT        10
  246.         :XMN_BUTTONS        #("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
  247.         :XMN_BUTTON_MNEMONICS    #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  248.         :XMN_BUTTON_SET        9
  249.         ))
  250. ;;;
  251. ;;; WORK AROUND WINTERP's MISSING support for :XMN_SIMPLE_CALLBACK:
  252. ;;; We cannot attach a :XMN_ENTRY_CALLBACK on the widget instance returned from
  253. ;;; XM_ROW_COLUMN_WIDGET_CLASS/:simple_option_menu.
  254. ;;; The reason for this is that the option menu is composed of a label + cascade
  255. ;;; button, with the cascade attached to a pulldown. The :XMN_ENTRY_CALLBACK
  256. ;;; would have to occur on the pulldown menu, not on the option r/c. Thus,
  257. ;;; we need to attach the entry callback to the widgetobj returned by doing
  258. ;;; :get_values on resource XmNsubMenuId. However, due to a weird bug in
  259. ;;; Motif 1.1, you have to use method :GET_SUB_MENU_WIDGET instead of retrieving
  260. ;;; :XMN_SUB_MENU_ID.
  261. ;;;
  262. (send (send op1_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  263.        :set_callback :XMN_ENTRY_CALLBACK
  264.       '(CALLBACK_ENTRY_WIDGET)
  265.        '(
  266.       (format T "Option-Menu 1 Select: name==~A label==~A\n"
  267.         (send CALLBACK_ENTRY_WIDGET :name)
  268.           (xm_string_get_l_to_r
  269.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  270.       ))
  271. (send (send op2_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  272.        :set_callback :XMN_ENTRY_CALLBACK
  273.       '(CALLBACK_ENTRY_WIDGET)
  274.        '(
  275.       (format T "Option-Menu 2 Select: name==~A label==~A\n"
  276.         (send CALLBACK_ENTRY_WIDGET :name)
  277.           (xm_string_get_l_to_r
  278.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  279.       ))
  280. (send (send op3_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  281.        :set_callback :XMN_ENTRY_CALLBACK
  282.       '(CALLBACK_ENTRY_WIDGET)
  283.        '(
  284.       (format T "Option-Menu 3 Select: name==~A label==~A\n"
  285.         (send CALLBACK_ENTRY_WIDGET :name)
  286.           (xm_string_get_l_to_r
  287.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  288.       ))
  289. (send (send op4_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  290.        :set_callback :XMN_ENTRY_CALLBACK
  291.       '(CALLBACK_ENTRY_WIDGET)
  292.        '(
  293.       (format T "Option-Menu 4 Select: name==~A label==~A\n"
  294.         (send CALLBACK_ENTRY_WIDGET :name)
  295.           (xm_string_get_l_to_r
  296.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  297.       ))
  298. (send (send op5_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  299.        :set_callback :XMN_ENTRY_CALLBACK
  300.       '(CALLBACK_ENTRY_WIDGET)
  301.        '(
  302.       (format T "Option-Menu 5 Select: name==~A label==~A\n"
  303.         (send CALLBACK_ENTRY_WIDGET :name)
  304.           (xm_string_get_l_to_r
  305.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  306.       ))
  307. (send (send op6_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  308.        :set_callback :XMN_ENTRY_CALLBACK
  309.       '(CALLBACK_ENTRY_WIDGET)
  310.        '(
  311.       (format T "Option-Menu 6 Select: name==~A label==~A\n"
  312.         (send CALLBACK_ENTRY_WIDGET :name)
  313.           (xm_string_get_l_to_r
  314.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  315.       ))
  316. (send (send op7_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  317.        :set_callback :XMN_ENTRY_CALLBACK
  318.       '(CALLBACK_ENTRY_WIDGET)
  319.        '(
  320.       (format T "Option-Menu 7 Select: name==~A label==~A\n"
  321.         (send CALLBACK_ENTRY_WIDGET :name)
  322.           (xm_string_get_l_to_r
  323.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  324.       ))
  325. (send (send op8_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  326.        :set_callback :XMN_ENTRY_CALLBACK
  327.       '(CALLBACK_ENTRY_WIDGET)
  328.        '(
  329.       (format T "Option-Menu 8 Select: name==~A label==~A\n"
  330.         (send CALLBACK_ENTRY_WIDGET :name)
  331.           (xm_string_get_l_to_r
  332.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  333.       ))
  334. (send (send op9_w :GET_SUB_MENU_WIDGET)    ;must use :GET_SUB_MENU_WIDGET rather than :get_values/:xmn_sub_menu_id, since that one reveals 1.1 bug.
  335.        :set_callback :XMN_ENTRY_CALLBACK
  336.       '(CALLBACK_ENTRY_WIDGET)
  337.        '(
  338.       (format T "Option-Menu 9 Select: name==~A label==~A\n"
  339.         (send CALLBACK_ENTRY_WIDGET :name)
  340.           (xm_string_get_l_to_r
  341.            (send CALLBACK_ENTRY_WIDGET :get :XMN_LABEL_STRING)))
  342.       ))
  343.  
  344. (send top_w :realize)
  345.  
  346. )
  347. )
  348.